Chip 2000 November

home *** CD-ROM | disk | FTP | other *** search

/ Chip 2000 November / Chip Kasım 2000.iso / prog / share / 11 / setup.exe / %MAINDIR% / DEMOS / CIFTP / FTPCLASS / FRMFTP.FRM (.txt) < prev next >

Wrap

Visual Basic Form | 2000-09-07 | 24.3 KB | 672 lines

VERSION 4.00 Begin VB.Form frmFTP BackColor = &H00C0C0C0& Caption = "FTP Class Demo" ClientHeight = 5430 ClientLeft = 2595 ClientTop = 2535 ClientWidth = 7365 Height = 5880 Icon = "FRMFTP.frx":0000 Left = 2535 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 5430 ScaleWidth = 7365 Top = 2145 Width = 7485 Begin VB.TextBox PercentGauge BackColor = &H00C0C0C0& ForeColor = &H00000000& Height = 285 Left = 1590 TabIndex = 16 Top = 5055 Width = 570 End Begin VB.TextBox txtStatus BackColor = &H00C0C0C0& Height = 360 Left = 60 TabIndex = 14 TabStop = 0 'False Text = "Ready" Top = 4605 Width = 7185 End Begin VB.Frame Frame2 Caption = "Remote Files" Height = 4365 Left = 3090 TabIndex = 4 Top = 150 Width = 4140 Begin VB.ComboBox cboHostName BackColor = &H00FFFFFF& Height = 315 ItemData = "FRMFTP.frx":0442 Left = 180 List = "FRMFTP.frx":0452 TabIndex = 13 Text = "ftp.progress.com" Top = 360 Width = 2535 End Begin VB.ListBox lstFiles Height = 1425 Left = 180 MultiSelect = 2 'Extended TabIndex = 12 Top = 2745 Width = 2535 End Begin VB.ListBox lstDirs Height = 1845 IntegralHeight = 0 'False Left = 180 TabIndex = 11 Top = 810 Width = 2535 End Begin VB.CommandButton cmdLogin Caption = "&Login" Height = 370 Left = 2925 TabIndex = 10 Top = 360 Width = 960 End Begin VB.CommandButton cmdAbort Caption = "&Abort" Height = 370 Left = 2925 TabIndex = 9 Top = 810 Width = 960 End Begin VB.CommandButton cmdQuit Caption = "&Quit" Height = 370 Left = 2925 TabIndex = 8 Top = 1260 Width = 960 End Begin VB.CheckBox chkAutoUpdate Caption = "Auto &Update" Height = 420 Left = 2835 TabIndex = 7 Top = 3510 Width = 1275 End Begin VB.CheckBox chkBinary Caption = "&Binary" Height = 375 Left = 2835 TabIndex = 6 Top = 2655 Value = 1 'Checked Width = 1050 End Begin VB.CheckBox chkConfirm Caption = "&Confirm" Height = 420 Left = 2835 TabIndex = 5 Top = 3060 Value = 1 'Checked Width = 1275 End End Begin VB.Frame Frame1 Caption = "Local Files" Height = 4365 Left = 75 TabIndex = 0 Top = 150 Width = 2940 Begin VB.FileListBox File1 Height = 1425 Left = 225 MultiSelect = 2 'Extended TabIndex = 3 Top = 2715 Width = 2535 End Begin VB.DirListBox Dir1 Height = 1830 Left = 225 TabIndex = 2 Top = 810 Width = 2535 End Begin VB.DriveListBox Drive1 BackColor = &H00FFFFFF& Height = 315 Left = 225 TabIndex = 1 Top = 360 Width = 2535 End End Begin VB.Label Label1 Caption = "Percent Completed:" Height = 285 Left = 60 TabIndex = 15 Top = 5070 Width = 1560 End Begin VB.Image imgDragStart Height = 480 Left = 7515 Picture = "FRMFTP.frx":0498 Top = 2115 Visible = 0 'False Width = 480 End Begin VB.Image imgInvalid Height = 480 Left = 7515 Picture = "FRMFTP.frx":08DA Top = 1485 Visible = 0 'False Width = 480 End Begin CIFTPLib.CIFTP FTP Height = 450 Left = 7470 Top = 2835 Width = 480 _Version = 65537 _ExtentX = 847 _ExtentY = 794 _StockProps = 0 AccessChannelConnectionWAV= "" AccessChannelClosedWAV= "" DataChannelConnectionWAV= "" DataChannelClosedWAV= "" FileClosedWAV = "" ListBoxesPopulatedWAV= "" SocketClosedWAV = "" WSAErrorWAV = "" HostName = "ftp.progress.com" HostAddress = "" RemoteFileName = "" LoginName = "anonymous" Password = "swan@nashua.progress.com" RepresentationType= "" WorkingDirectory= "" End Attribute VB_Name = "frmFTP" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' SUBJECT: frmFTP ' AUTHOR: David M Swan ' Progress Software Corporation ' Crescent Division ' CREATED: December 8, 1996 ' REVISION ' HISTORY: ' DESCRIPTION: Demonstrates how you might use the clsFTP wrapper class ' See FtpClass.wri for detailed description of the class. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Module scope variable declarations '========================== Dim cFTP As New clsFTP ' the CIFTP wrapper class Dim m_lFileSize As Long ' used to monitor progress of file transfers Dim m_CurrentControl As Variant ' used by HandleMouseMove to provide UI feedback Private Sub chkAutoUpdate_GotFocus() HandleMouseMove chkAutoUpdate End Sub Private Sub chkAutoUpdate_LostFocus() HandleMouseMove End Sub Private Sub chkAutoUpdate_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove chkAutoUpdate End Sub Private Sub chkBinary_GotFocus() HandleMouseMove chkBinary End Sub Private Sub chkBinary_LostFocus() HandleMouseMove End Sub Private Sub chkBinary_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove chkBinary End Sub Private Sub chkConfirm_GotFocus() HandleMouseMove chkConfirm End Sub Private Sub chkConfirm_LostFocus() HandleMouseMove End Sub Private Sub chkConfirm_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove chkConfirm End Sub Private Sub cmdAbort_Click() If Not cFTP.bAbort Then UpdateStatus cFTP.sGetLastError, vbRed Else UpdateStatus "Ready" End If End Sub Private Sub cmdAbort_GotFocus() HandleMouseMove cmdAbort End Sub Private Sub cmdAbort_LostFocus() HandleMouseMove End Sub Private Sub cmdAbort_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove cmdAbort End Sub Private Sub cmdLogin_Click() Dim bSuccess As Boolean cmdLogin.Enabled = False ' disable button while processing request cboHostName.SelLength = 0 ' clear any selected text in host name field (looks better) If cmdLogin.Caption = "&Login" Then ' Attempt to make an anonymous connection with the host specified ' We could easily modify this to use a specific username & password if desired UpdateStatus "Connecting to: " & cboHostName.Text If Not cFTP.bLogin(cboHostName.Text, "anonymous", "someone@someplace.com") Then UpdateStatus cFTP.sGetLastError, vbRed Else ' modify UI to indicate connection has been made... UpdateStatus "Connected to: " & cboHostName.Text cmdLogin.Caption = "&Logout" cboHostName.Font.Bold = True cboHostName.BackColor = vbGreen cboHostName.SelLength = 0 cboHostName.Enabled = False GetDirectory ' update the directory listing End If Else ' we're logging out... UpdateStatus "Logging Out Of: " & cboHostName.Text DoEvents bSuccess = cFTP.bLogout() If Not bSuccess Then UpdateStatus cFTP.sGetLastError, vbRed Else DoEvents End If ' Even if we "failed" to log out, the connection may have been lost (for example, ' due to a timeout), so handle this case by resetting the environment if the ' access channel has been dropped (as indicated by the result of bLoggedIn) If bSuccess Or Not cFTP.bLoggedIn() Then ' This will be True if bLogout succeeded OR if the server dropped the connection UpdateStatus "No Connection" ' modify UI to indicate that they have logged out of the ftp server... lstDirs.Clear lstFiles.Clear cmdLogin.Caption = "&Login" cboHostName.Enabled = True cboHostName.BackColor = vbWhite cboHostName.Font.Bold = False cboHostName.SelLength = 0 FTP.WorkingDirectory = "" frmFTP.Caption = "FTP Class Demo" End If End If cmdLogin.Enabled = True ' re-enable button now that request has been processed End Sub Private Sub GetDirectory() UpdateStatus "Updating directory listing..." If Not cFTP.bGetDirectory Then UpdateStatus cFTP.sGetLastError, vbRed Else UpdateStatus "Ready" UpdatePath End If End Sub Private Sub UpdateStatus(sStatus As String, Optional vntColor) ' updates the status information displayed at the bottom of the form ' If a color was specified use it, otherwise default to using black Dim lColor As Long If IsMissing(vntColor) Then lColor = vbBlack Else lColor = CLng(vntColor) txtStatus.ForeColor = lColor txtStatus.Text = sStatus End Sub ' UpdateStatus Private Sub UpdatePath() frmFTP.Caption = FTP.WorkingDirectory End Sub Private Sub cmdLogin_GotFocus() HandleMouseMove cmdLogin End Sub Private Sub cmdLogin_LostFocus() HandleMouseMove End Sub Private Sub cmdLogin_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove cmdLogin End Sub Private Sub HandleMouseMove(Optional O) ' Provide visual feedback to users. ' This routine is called when the user moves the mouse ' over various interface controls (buttons, checkboxes) in ' the remote files area. If no control is passed in the optional ' parameter then the currently highlighted control (if any) is ' unhighlighted. On Error GoTo HandleMouseMove_ErrHdlr ' If no control was passed and no control has been set, then ' no action is required If IsMissing(O) And IsEmpty(m_CurrentControl) Then Exit Sub ' If no control has been passed, but a control has been previously ' set, then we need to restore the control to its original state If IsMissing(O) And Not IsEmpty(m_CurrentControl) Then m_CurrentControl.Font.Bold = False m_CurrentControl = Empty Exit Sub End If ' If a control was passed AND a control has been previously set, ' then we need to restore the old control and set the new one. If Not IsMissing(O) And Not IsEmpty(m_CurrentControl) Then ' if it's the same control again, then we can bail out If m_CurrentControl.Name = O.Name Then Exit Sub ' if the saved control is "bold", then reset it If m_CurrentControl.Font.Bold = True Then m_CurrentControl.Font.Bold = False ' if the new control's font is not already bold, then set it If Not O.Font.Bold Then MakeCurrentControl O ' otherwise, it may be the first object being handled, ' so set its font to bold ElseIf Not IsMissing(O) And IsEmpty(m_CurrentControl) Then MakeCurrentControl O End If Exit Sub HandleMouseMove_ErrHdlr: Debug.Print "ERROR: " & Err.Description End Sub ' HandleMouseMove Sub MakeCurrentControl(O As Variant) ' Make the passed in control the "current" control, ' make its caption bold and give it the input focus On Error GoTo MakeCurrentControl_ErrHdlr Set m_CurrentControl = O O.Font.Bold = True If frmFTP.ActiveControl.Name <> O.Name Then O.SetFocus End If MakeCurrentControl_ErrHdlr: End Sub Private Sub cmdQuit_Click() ' If we're logged in, then logout before ending... If cFTP.bLoggedIn() Then If Not cFTP.bLogout() Then UpdateStatus cFTP.sGetLastError(), vbRed End If End If Set frmFTP = Nothing End End Sub Private Sub cmdQuit_GotFocus() HandleMouseMove cmdQuit End Sub Private Sub cmdQuit_LostFocus() HandleMouseMove End Sub Private Sub cmdQuit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove cmdQuit End Sub Private Sub Dir1_Change() File1.Path = Dir1.Path End Sub Private Sub Dir1_DragDrop(Source As Control, X As Single, Y As Single) HandleLocalDragDrop Source End Sub Private Sub Dir1_DragOver(Source As Control, X As Single, Y As Single, State As Integer) HandleValidDropTarget Dir1 End Sub Private Sub Drive1_Change() Dir1.Path = Drive1.Drive End Sub Private Sub File1_DragDrop(Source As Control, X As Single, Y As Single) HandleLocalDragDrop Source End Sub Private Sub HandleLocalDragDrop(Source As Control) ' Transfer remote file to local dir Dim iResponse As Integer, iStyle As Integer, sMsg As String, sTitle As String Dim sLocalFileName As String, sRemoteFileName As String, i As Integer On Error Resume Next If Source.Name = "File1" Or Source.Name = "Dir1" Then Exit Sub ' don't allow drop on self iStyle = vbYesNo + vbQuestion + vbDefaultButton2 sTitle = "Transfer Remote File" ' Loop thru all the selected files... For i = 0 To lstFiles.ListCount - 1 If lstFiles.Selected(i) Then If Right(File1.Path, 1) <> "\" Then sLocalFileName = File1.Path & "\" & lstFiles.List(i) Else sLocalFileName = File1.Path & lstFiles.List(i) End If sRemoteFileName = lstFiles.List(i) m_lFileSize = FTP.Files(sRemoteFileName).FileSize ' determine the size of the remote file If chkConfirm = vbChecked Then sMsg = "Copy " & sRemoteFileName & " [" & m_lFileSize & " bytes] to " & File1.Path & "?" iResponse = MsgBox(sMsg, iStyle, sTitle) Else iResponse = vbYes End If If iResponse = vbYes Then ' User chose Yes. GetRemoteFile sLocalFileName, sRemoteFileName End If End If Next i End Sub ' HandleLocalDrop Private Sub File1_DragOver(Source As Control, X As Single, Y As Single, State As Integer) HandleValidDropTarget Source End Sub Private Sub File1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If File1.ListIndex >= 0 And cFTP.bLoggedIn Then File1.DragIcon = imgDragStart.Picture File1.Drag End If End Sub Private Sub HandleInvalidDropTarget(C As Control) C.DragIcon = imgInvalid End Sub Private Sub HandleValidDropTarget(C As Control) C.DragIcon = imgDragStart End Sub Private Sub GetRemoteFile(sLocalFileName As String, sRemoteFileName As String) Dim bBinaryFile As Boolean On Error Resume Next ' Handle special case of 0 len files... If m_lFileSize = 0 Then UpdateStatus sRemoteFileName & " is a zero length file. Aborting operation", vbRed Exit Sub End If ' Update UI... PercentGauge.Text = 0 UpdateStatus "Transfering " & sRemoteFileName & "..." bBinaryFile = (chkBinary.Value = vbChecked) ' Use the wrapper class to perform the file transfer from the remote system... If Not cFTP.bGetFile(sLocalFileName, sRemoteFileName, bBinaryFile) Then UpdateStatus "File transfer failed - " & cFTP.sGetLastError, vbRed Else UpdateStatus "Ready" File1.Refresh ' update file list to reflect the new file End If ' Hide the percent gauge PercentGauge.Text = 0 m_lFileSize = 0 End Sub ' GetRemoteFile Private Sub PutLocalFile(sLocalFileName As String, sRemoteFileName As String) Dim bSuccess As Boolean, bBinaryFile As Boolean On Error Resume Next ' Update UI PercentGauge.Text = 0 UpdateStatus "Transfering " & sLocalFileName & "..." DoEvents bBinaryFile = (chkBinary.Value = vbChecked) ' Use the wrapper class to perform the file transfer to the remote system... bSuccess = cFTP.bPutFile(sLocalFileName, sRemoteFileName, bBinaryFile) ' Update UI and report results... PercentGauge.Text = 0 If Not bSuccess Then UpdateStatus "File transfer failed - " & cFTP.sGetLastError, vbRed Else UpdateStatus "Ready" If chkAutoUpdate.Value = vbChecked Then GetDirectory ' update directory listing to reflect new file End If End If m_lFileSize = 0 End Sub ' PutLocalFile Private Sub fmOptions_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove End Sub Private Sub Form_Load() On Error Resume Next Dim bSuccess As Boolean ' Set initial login values in the FTP control... With FTP Set .DirectoryListBoxName = lstDirs Set .FileListBoxName = lstFiles .LoginName = "anonymous" .Password = "someone@someplace.com" .HostName = "ftp.progress.com" .WorkingDirectory = "/" End With ' Now Initialize the FTP wrapper class by passing it the FTP control ' This MUST be done before any of the other wrapper functions can be called, ' so you should do this at startup (in form load, sub main, etc) bSuccess = cFTP.bInit(FTP) If Not bSuccess Then UpdateStatus cFTP.sGetLastError(), vbRed MsgBox "ERROR: Unable to initialize FTP class module!" ShutDown End If ' Set the initial drive/path values for the local file viewing controls... Drive1.Drive = "C" Dir1.Path = "C:\TEMP" PercentGauge.Text = 0 End Sub Public Sub ShutDown() ' Do other shut down related stuff here End End Sub ' ShutDown Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove End Sub Private Sub FTP_AccessControlPacketReceived(ByVal Packet As String) ' forward the event to the wrapper class... cFTP.AccessControlPacketReceived Packet End Sub Private Sub FTP_DataControlPacketReceived(ByVal Packet As String, ByVal bytes_in As Integer) ' forward the event to the wrapper class... cFTP.DataControlPacketReceived Packet, bytes_in ' Update the percent meter if a file transfer is underway... Dim iPercent As Integer If m_lFileSize > 0 Then iPercent = CInt((cFTP.lTotalDataBytesIn / m_lFileSize) * 100) If iPercent > 100 Then iPercent = 100 PercentGauge.Text = iPercent '.FloodPercent = iPercent PercentGauge.Refresh End If End Sub Private Sub FTP_DataControlPacketSent(ByVal bytes_out As Integer) ' forward the event to the wrapper class... cFTP.DataControlPacketSent bytes_out ' Update the percent meter if a file transfer is underway... Dim iPercent As Integer If m_lFileSize > 0 Then iPercent = CInt((cFTP.lTotalDataBytesOut / m_lFileSize) * 100) If iPercent > 100 Then iPercent = 100 ' make sure we don't overflow PercentGauge.Text = iPercent PercentGauge.Refresh DoEvents ' Allow user to click on "Abort" button End If End Sub Private Sub FTP_EventStateChanged(ByVal State As Integer) ' forward the event to the wrapper class... cFTP.EventStateChanged State End Sub Private Sub FTP_InternetError(ByVal error_number As Long, ByVal error_message As String) ' forward the event to the wrapper class... cFTP.InternetError error_number, error_message End Sub Private Sub FTP_ServerResponse(ByVal ResponseCode As Integer, ByVal ResponseString As String) ' forward the event to the wrapper class... cFTP.ServerResponse ResponseCode, ResponseString End Sub Private Sub FTP_WSAError(ByVal error_number As Integer) ' forward the event to the wrapper class... cFTP.WSAError error_number End Sub Private Sub lstDirs_DblClick() ' change directories as specified by the WorkingDirectory property... With FTP If .WorkingDirectory = "/" Then .WorkingDirectory = "/" & lstDirs.List(lstDirs.ListIndex) Else .WorkingDirectory = .WorkingDirectory & "/" & lstDirs.List(lstDirs.ListIndex) End If End With UpdateStatus "Setting WorkingDirectory to: " & FTP.WorkingDirectory If Not cFTP.bGetDirectory() Then UpdateStatus cFTP.sGetLastError, vbRed Else UpdateStatus "Ready" UpdatePath End If End Sub Private Sub lstDirs_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove End Sub Private Sub lstFiles_DragDrop(Source As Control, X As Single, Y As Single) HandleRemoteDragDrop Source End Sub Private Sub HandleRemoteDragDrop(Source As Control) ' Transfer local file to ftp server Dim iResponse As Integer, iStyle As Integer, sMsg As String, sTitle As String Dim sLocalFileName As String, sRemoteFileName As String, i As Integer On Error Resume Next If Source.Name = "lstFiles" Then Exit Sub ' don't allow drop on self iStyle = vbYesNo + vbQuestion + vbDefaultButton2 sTitle = "Transfer Local File" ' Loop thru all the selected files... For i = 0 To File1.ListCount - 1 If File1.Selected(i) Then If Right(File1.Path, 1) <> "\" Then sLocalFileName = File1.Path & "\" & File1.List(i) Else sLocalFileName = File1.Path & File1.List(i) End If sRemoteFileName = File1.List(i) m_lFileSize = FileLen(sLocalFileName) ' determine the length of the file being sent If chkConfirm.Value = vbChecked Then sMsg = "Copy " & sLocalFileName & " [" & m_lFileSize & " bytes] to " & FTP.WorkingDirectory & "?" iResponse = MsgBox(sMsg, iStyle, sTitle) Else iResponse = vbYes End If If iResponse = vbYes Then ' User chose Yes. PutLocalFile sLocalFileName, sRemoteFileName End If End If Next i End Sub Private Sub lstFiles_DragOver(Source As Control, X As Single, Y As Single, State As Integer) HandleValidDropTarget Source End Sub Private Sub lstFiles_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If lstFiles.ListIndex >= 0 Then lstFiles.DragIcon = imgDragStart lstFiles.Drag End If End Sub Private Sub lstFiles_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove End Sub Private Sub SSFrame1_DragOver(Source As Control, X As Single, Y As Single, State As Integer) HandleInvalidDropTarget Source End Sub Private Sub SSFrame2_DragOver(Source As Control, X As Single, Y As Single, State As Integer) HandleInvalidDropTarget Source End Sub Private Sub SSFrame2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) HandleMouseMove End Sub Private Sub txtStatus_KeyPress(KeyAscii As Integer) KeyAscii = 0 ' trap user input End Sub